User's Choice Windows CD/User's Choice Windows CD (CMS Software)(1993).iso/windows5/vbterm.zip/SERIAL.BAS

BASIC Source File | 1991-09-01 | 7KB | 257 lines

'
'   FILE    SERIAL.BAS
'
'       This is the code to handle the interface to the windows comm API
'
'   Charles McGuinness [76701,11]
'
'
'    Serial Communications Module for VB
'

'
'  COMM declarations
'
Const NOPARITY = 0
Const ODDPARITY = 1
Const EVENPARITY = 2
Const MARKPARITY = 3
Const SPACEPARITY = 4

Const ONESTOPBIT = 0
Const ONE5STOPBITS = 1
Const TWOSTOPBITS = 2

Const IGNORE = 0 '  Ignore signal
Const INFINITE = &HFFFF  '  Infinite timeout

'  Error Flags
Const CE_RXOVER = &H1    '  Receive Queue overflow
Const CE_OVERRUN = &H2   '  Receive Overrun Error
Const CE_RXPARITY = &H4  '  Receive Parity Error
Const CE_FRAME = &H8     '  Receive Framing error
Const CE_BREAK = &H10    '  Break Detected
Const CE_CTSTO = &H20    '  CTS Timeout
Const CE_DSRTO = &H40    '  DSR Timeout
Const CE_RLSDTO = &H80   '  RLSD Timeout
Const CE_TXFULL = &H100  '  TX Queue is full
Const CE_PTO = &H200     '  LPTx Timeout
Const CE_IOE = &H400     '  LPTx I/O Error
Const CE_DNS = &H800     '  LPTx Device not selected
Const CE_OOP = &H1000    '  LPTx Out-Of-Paper
Const CE_MODE = &H8000   '  Requested mode unsupported

Const IE_BADID = (-1)    '  Invalid or unsupported id
Const IE_OPEN = (-2)     '  Device Already Open
Const IE_NOPEN = (-3)    '  Device Not Open
Const IE_MEMORY = (-4)   '  Unable to allocate queues
Const IE_DEFAULT = (-5)  '  Error in default parameters
Const IE_HARDWARE = (-10)        '  Hardware Not Present
Const IE_BYTESIZE = (-11)        '  Illegal Byte Size
Const IE_BAUDRATE = (-12)        '  Unsupported BaudRate

'  Events
Const EV_RXCHAR = &H1    '  Any Character received
Const EV_RXFLAG = &H2    '  Received certain character
Const EV_TXEMPTY = &H4   '  Transmitt Queue Empty
Const EV_CTS = &H8       '  CTS changed state
Const EV_DSR = &H10      '  DSR changed state
Const EV_RLSD = &H20     '  RLSD changed state
Const EV_BREAK = &H40    '  BREAK received
Const EV_ERR = &H80      '  Line status error occurred
Const EV_RING = &H100    '  Ring signal detected
Const EV_PERR = &H200    '  Printer error occured

'  Escape Functions
Const SETXOFF = 1        '  Simulate XOFF received
Const SETXON = 2 '  Simulate XON received
Const SETRTS = 3 '  Set RTS high
Const CLRRTS = 4 '  Set RTS low
Const SETDTR = 5 '  Set DTR high
Const CLRDTR = 6 '  Set DTR low
Const RESETDEV = 7       '  Reset device if possible

Const LPTx = &H80        '  Set if ID is for LPT device


Declare Function OpenComm Lib "User" (ByVal lpComName As String, ByVal wInQueue As Integer, ByVal wOutQueue As Integer) As Integer
Declare Function SetCommState Lib "User" (lpDCB As DCB) As Integer
Declare Function GetCommState Lib "User" (ByVal nCid As Integer, lpDCB As DCB) As Integer
Declare Function ReadComm Lib "User" (ByVal nCid As Integer, ByVal lpBuf As String, ByVal nSize As Integer) As Integer
Declare Function UngetCommChar Lib "User" (ByVal nCid As Integer, ByVal cChar As Integer) As Integer
Declare Function WriteComm Lib "User" (ByVal nCid As Integer, ByVal lpBuf As String, ByVal nSize As Integer) As Integer
Declare Function CloseComm Lib "User" (ByVal nCid As Integer) As Integer
Declare Function BuildCommDCB Lib "User" (ByVal lpDef As String, lpDCB As DCB) As Integer
Declare Function TransmitCommChar Lib "User" (ByVal nCid As Integer, ByVal cChar As Integer) As Integer
Declare Function SetCommEventMask Lib "User" (ByVal nCid As Integer, nEvtMask As Integer) As Long
Declare Function GetCommEventMask Lib "User" (ByVal nCid As Integer, ByVal nEvtMask As Integer) As Integer
Declare Function SetCommBreak Lib "User" (ByVal nCid As Integer) As Integer
Declare Function ClearCommBreak Lib "User" (ByVal nCid As Integer) As Integer
Declare Function FlushComm Lib "User" (ByVal nCid As Integer, ByVal nQueue As Integer) As Integer
Declare Function EscapeCommFunction Lib "User" (ByVal nCid As Integer, ByVal nFunc As Integer) As Integer
Declare Function GetCommError Lib "User" (ByVal nCid As Integer, lpStat As Any) As Integer

'
'   Bits  for bits1 and bits2
'

'   Bits1
Const fbinary = &H1
Const frtsdiable = &H2
Const fparity = &H4
Const foutxctsflow = &H8
Const foutxdsrflow = &H10
Const fdtrdisable = &H80

'   Bits2

Const foutx = &H1
Const finx = &H2
Const fpechar = &H4
Const fnull = &H8
Const fchevt = &H10
Const fdtrflow = &H20
Const frtsflow = &H40

'
'   Definitions of our open port
'
Dim nCid        As Integer
Dim PortName    As String
Dim OutSize     As Integer
Dim lpDCB       As DCB

Function SerialOpen (ComPort As Integer) As Integer
'
'    Open the serial port. Expects the com port number as the argument
'    and returns either zero for success, or non-zero on error
'
    PortName = "COM" + Format$(ComPort, "#")
    OutSize = 256
    nCid = OpenComm(PortName, 2048, OutSize)
    If (nCid < 0) Then
        SerialOpen = nCid
    Else
        SerialOpen = 0
    End If
End Function

Function SerialClose () As Integer
'
'    Closes the serial port.  Zero return on OK
'
    x% = CloseComm(nCid)
    If (x% < 0) Then
        SerialClose = x%
    Else
        SerialClose = 0
    End If
End Function

Function SerialConfig (baud%, bits%, Parity$) As Integer
'
'    Configure the open serial port
'
    Dim ConfigString As String

    ConfigString = PortName + ":"

    ConfigString = ConfigString + Format$(baud%) + ","

    ConfigString = ConfigString + Left$(UCase$(Parity$), 1) + ","

    ConfigString = ConfigString + Format$(bits%, "#") + ",1"

    i% = BuildCommDCB(ConfigString, lpDCB)

    lpDCB.id = Chr$(nCid)
    lpDCB.bits2 = Chr$(Asc(lpDCB.bits2) Or finx)
    lpDCB.XonChar = Chr$(Asc("Q") - 64)
    lpDCB.XoffChar = Chr$(Asc("S") - 64)
    lpDCB.XonLim = 256
    lpDCB.XoffLim = 256

    SerialConfig = SetCommState(lpDCB)

End Function

Function serialwrite (t$) As Integer

    If (SerialOutFree() < Len(t$)) Then

        '   Wait for enough space in our buffer
        Do
            x% = DoEvents()
        Loop While SerialOutFree() < Len(t$)

    End If

    serialwrite = WriteComm(nCid, t$, Len(t$))

End Function

Function SerialRead (buf$, max%) As Integer
'    Dim st As COMSTAT
    Static last As Integer


    i% = ReadComm(nCid, buf$, max%)
    SerialRead = i%

    If (i% < 0) Or ((i% = 0) And (last = 0)) Then
        status% = GetCommError(nCid, ByVal 0&)
        SerialRead = -i%
    End If

    last = i%

End Function

Sub SerialBreak (state%)
    If (state%) Then
        r% = SetCommBreak(nCid)
    Else
        r% = ClearCommBreak(nCid)
    End If

End Sub

Function SerialOutFree ()
'
'   Returns the amount of free space in the output
'   buffer (to prevent overruns, provide pacing, etc.)
'
    Dim st As COMSTAT

    status% = GetCommError(nCid, st)

    If (status% <> 0) Then Beep

    SerialOutFree = OutSize - st.cbOutQue

End Function

Sub serialbinary (yesno As Integer)

    Dim TempDCB As DCB

    If (yesno = 0) Then     ' Turn off Binary Mode
        x% = SetCommState(lpDCB)
        Exit Sub
    End If

    ' Turn On Binary Mode
    TempDCB = lpDCB

    TempDCB.ByteSize = Chr$(8)

    TempDCB.Parity = Chr$(NOPARITY)

    TempDCB.bits1 = Chr$(fbinary)

    TempDCB.bits2 = Chr$(0)

    x% = SetCommState(TempDCB)
End Sub